open Fr
open FrGui_common

type action_label = {
	text: string;
	icon: image option;
	short_text: string option;
	tooltip: string option;
}

type action_item =
	| Button of unit event_receiver
	| Toggle of bool * bool cell
	| Radio of int * bool * unit event_receiver
	| Menu of action_group
and action = {
	item: action_item;
	label: action_label;
	enabled: bool behavior option;
}
and action_group =
	| Items of action list
	| Groups of action_group list
	| Dynamic of action_group behavior

let gen_radio_group_id =
	let free_id = ref 0 in fun () ->
	let id = !free_id in
	incr free_id; id

let action ?enabled ?icon ?label ?tooltip text value =
	let r, e = event_receiver ()
	and label = {
		text = text;
		icon = icon;
		short_text = label;
		tooltip = tooltip;
	} in
	{ item = Button r; label = label; enabled = enabled }, tag_e value e

let toggle_action ?enabled ?icon ?label ?tooltip text init =
	let c, b = new_cell init
	and label = {
		text = text;
		icon = icon;
		short_text = label;
		tooltip = tooltip;
	} in
	{ item = Toggle (init, c); label = label; enabled = enabled }, b

let text_radio_action_group ?enabled options init =
	match options with
	| [] -> assert false
	| (text_hd, value_hd) :: tl ->
		let group_id = gen_radio_group_id ()
		and found_init = ref false in
		let a_tl, e_tl = List.split (List.map (fun (text, value) ->
			let r, e = event_receiver ()
			and label = {
				text = text;
				icon = None;
				short_text = None;
				tooltip = None;
			}
			and active = not !found_init && value =* init in
			if active then found_init := true;
			{ item = Radio (group_id, active, r); label = label; enabled = enabled }, tag_e value e) tl) in
		let a_hd, e_hd =
			let r, e = event_receiver ()
			and label = {
				text = text_hd;
				icon = None;
				short_text = None;
				tooltip = None;
			}
			and active = not !found_init in
			{ item = Radio (group_id, active, r); label = label; enabled = enabled }, tag_e value_hd e in
		a_hd :: a_tl, hold init (merge_e (e_hd :: e_tl))

let submenu ?enabled ?icon ?label ?tooltip text menu =
	let label = {
		text = text;
		icon = icon;
		short_text = label;
		tooltip = tooltip;
	} in
	{ item = Menu menu; label = label; enabled = enabled }

let group items = Items items
let join_groups groups = Groups groups
let collapse_a b = Dynamic b
let switch_a i e = collapse_a (hold i e)


(* widget generation (internal) *)

let rec gtk_menu_item ?detachable =
	let radio_group_tbl = Hashtbl.create 13 in fun action ->
	let widget = match action.item with
		| Button r ->
			let widget =
				match action.label.icon with
				| None -> GMenu.menu_item ~label: action.label.text ()
				| Some image ->
					(GMenu.image_menu_item
						~image: (gtk_image ~icon_size: `MENU image)
						~label: action.label.text () :> GMenu.menu_item) in
			ignore (widget#connect#activate (send_event r));
			(widget :> GMenu.menu_item)
		| Toggle (active, c) ->
			let widget =
				GMenu.check_menu_item ~label: action.label.text ~active () in
			ignore (widget#connect#toggled (fun () -> set_cell c widget#active));
			(widget :> GMenu.menu_item)
		| Radio (group_id, active, r) ->
			let widget =
				try
					let group = Hashtbl.find radio_group_tbl group_id in
					GMenu.radio_menu_item ~group ~label: action.label.text ~active ()
				with Not_found ->
					let widget = GMenu.radio_menu_item ~label: action.label.text ~active () in
					Hashtbl.add radio_group_tbl group_id widget#group;
					widget in
			ignore (widget#connect#toggled (send_event r));
			(widget :> GMenu.menu_item)
		| Menu action_group ->
			let widget =
				match action.label.icon with
				| None -> GMenu.menu_item ~label: action.label.text ()
				| Some image ->
					(GMenu.image_menu_item
						~image: (gtk_image ~icon_size: `MENU image)
						~label: action.label.text () :> GMenu.menu_item) in
			widget#set_submenu (gtk_menu ?detachable action_group);
			(widget :> GMenu.menu_item)
	in
	option_may (fun enabled ->
		register_b_with widget (lift (widget#misc#set_state
			(if @enabled then `NORMAL else `INSENSITIVE)))) action.enabled;
	widget

and gtk_menu ?(detachable=false) action_group =
	let widget = GMenu.menu () in
	let rec linearize = function
		| Items items ->
			lift (List.map (gtk_menu_item ~detachable) items)
		| Groups (hd :: tl) ->
			lift begin
				List.fold_left
					(fun l w -> List.append w (GMenu.separator_item () :: l))
					@(linearize hd)
					@(par_b (List.rev_map linearize tl))
			end
		| Groups [] -> lift ([])
		| Dynamic menu ->
			collapse_b (lift1 linearize menu)
	and rebuild l =
		List.iter widget#remove widget#children;
		if detachable then ignore (GMenu.tearoff_item ~packing: widget#append ());
		List.iter widget#append l in
	register_b_with widget (lift1 rebuild (linearize action_group));
	widget

let gtk_menu_bar ?detachable action_group =
	let widget = GMenu.menu_bar () in
	let rec linearize rj = function
		| Items items ->
			lift (List.map (fun i -> gtk_menu_item ?detachable i, rj) items)
		| Groups menus ->
			let rec f = function
				| [] -> []
				| hd :: [] -> [linearize true hd]
				| hd :: tl -> linearize rj hd :: f tl
			in lift1 List.concat (par_b (f menus))
		| Dynamic menu ->
			collapse_b (lift1 (linearize rj) menu)
	and rebuild l =
		List.iter widget#remove widget#children;
		List.iter (fun (w, rj) -> w#set_right_justified rj; widget#append w) l in
	register_b_with widget (lift1 rebuild (linearize false action_group));
	widget

(* until we find a reason to use more than one of these...
   or find a better place to put it... *)
let global_tooltips = GData.tooltips ()

let rec gtk_toolbar_item ?detachable =
	let radio_group_tbl = Hashtbl.create 13 in fun action ->
	let widget = match action.item with
		| Button r ->
			let widget = GButton.tool_button () in
			ignore (widget#connect#clicked (send_event r));
			(widget :> GButton.tool_button_skel)
		| Toggle (active, c) ->
			let widget =
				GButton.toggle_tool_button ~active () in
			ignore (widget#connect#toggled (fun () -> set_cell c widget#get_active));
			(widget :> GButton.tool_button_skel)
		| Radio (group_id, active, r) ->
			let widget =
				try
					let group = Hashtbl.find radio_group_tbl group_id in
					GButton.radio_tool_button ~group ~active ()
				with Not_found ->
					let widget =
						GButton.radio_tool_button ~active () in
					Hashtbl.add radio_group_tbl group_id widget;
					widget in
			ignore (widget#connect#toggled (send_event r));
			(widget :> GButton.tool_button_skel)
		| Menu action_group ->
			(* TODO: there exists a GtkMenuToolButton in GTK 2.6+,
			   but it is not in lablgtk2 *)
			let widget = GButton.tool_button () in
			let menu = gtk_menu ?detachable action_group in
			ignore (widget#connect#clicked (fun () ->
				menu#popup 1 (GtkMain.Main.get_current_event_time ())));
			(widget :> GButton.tool_button_skel)
	in
	widget#set_label (option_default action.label.text action.label.short_text);
	option_may (function
			| Stock id -> widget#set_stock_id id
			| image -> widget#set_icon_widget (gtk_image image)#coerce)
		action.label.icon;
	option_may (fun tip -> widget#set_tooltip global_tooltips tip "")
		action.label.tooltip;
	option_may (fun enabled ->
			register_b_with widget (lift (widget#misc#set_state
				(if @enabled then `NORMAL else `INSENSITIVE))))
		action.enabled;
	(widget :> GButton.tool_item_skel)

let gtk_toolbar orientation ?detachable ?(text=false) ?large action_group =
	let widget = GButton.toolbar
		~orientation
		~style: (if text then `BOTH else `ICONS)
		~tooltips: true () in
	option_may (fun large -> widget#set_icon_size
		(if large then `LARGE_TOOLBAR else `SMALL_TOOLBAR)) large;

	let rec linearize = function
		| Items items ->
			lift (List.map (gtk_toolbar_item ?detachable) items)
		| Groups (hd :: tl) ->
			lift begin
				List.fold_left
					(fun l w ->
						List.append w ((GButton.separator_tool_item () :> GButton.tool_item_skel) :: l))
					@(linearize hd)
					@(par_b (List.rev_map linearize tl))
			end
		| Groups [] -> lift []
		| Dynamic group ->
			collapse_b (lift1 linearize group)
	and rebuild l =
		List.iter widget#remove widget#children;
		List.iter widget#insert l in
	register_b_with widget (lift1 rebuild (linearize action_group));
	widget

(*let gtk_toolbar_group ?detachable ?text action_group =
	let widget = GPack.vbox () in
	let rec linearize = function
		| Items items ->
			lift [(gtk_toolbar `HORIZONTAL ?detachable ?text (Items items)
				:> GObj.widget)]
		| Groups groups ->
			lift (List.map (gtk_toolbar `HORIZONTAL ?detachable ?text) groups
				:> GObj.widget list)
		| Dynamic group ->
			collapse_b (lift1 linearize group)
	and rebuild l =
		List.iter widget#remove widget#children;
		List.iter widget#pack l in
	register_b_with widget (lift1 rebuild (linearize action_group));
	widget*)

let add_popup_menu ?menu ?popup ?detachable widget =
	option_may
		(fun menu -> option_may
			(fun popup -> register_e_with widget
				(on popup () -> (gtk_menu ?detachable menu)#popup 3 (GtkMain.Main.get_current_event_time ())))
			popup)
		menu

let toolbar orientation ?text ?large action_group =
	(* This is a reasonable default, but let's not override
	   GTK user preferences for now *)
	(*let large = Some (option_default text large) in*)
	let widget =
		gtk_toolbar (gtk_orientation orientation) ?text ?large action_group in
	new simple_widget widget

let htoolbar = toolbar `Horizontal
let vtoolbar = toolbar `Vertical
